home
***
CD-ROM
|
disk
|
FTP
|
other
***
search
/
Tech Arsenal 1
/
Tech Arsenal (Arsenal Computer).ISO
/
tek-02
/
tp_dmx20.zip
/
DMXDFILE.PAS
< prev
next >
Wrap
Pascal/Delphi Source File
|
1990-01-15
|
8KB
|
290 lines
Unit DMXdFILE;
{$V-,I- }
(*
There are two DMX objects available for access to dBASE files:
dBMXwindow has been written to edit small files in memory,
with a predefined number of records.
dBrowser is for larger files. Its DataAt function has been rewritten
in order to get records from the disk, one-at-a-time.
An artificially high number of bytes should be passed to OpenBuffer
so that DMX will allow a large number of records.
The file DBENTRY.PAS demonstrates how these procedures are used.
*)
interface
uses Dos, Crt, DMX2, DMX_FILE;
type
dBMXwindow = object (Dwindow)
fheader : array [0..MaxFields] of headertype;
procedure dBASEopen (var Data; Size : longint; var F );
procedure dBASEwrite(var Data; var F );
procedure dBASEnew; virtual;
end;
dBrowser = object (dBMXwindow)
dbfrecord : array [0..255] of char;
workfile : dbfile;
procedure EvaluateRecord (RecNum :longint; Line :word);
virtual;
function DataAt (recnum : longint) : pointer;
virtual;
procedure ZeroizeRecord (var Data );
virtual;
procedure dBASEinit (Filename : pathstr);
procedure dBASEclose;
end;
implementation
{ ─────────────────────────────────────────────────────────────────────── }
procedure dBMXwindow.dBASEnew;
{ virtual procedure for new setup }
var i,j,k,l,m : word;
AStr : string;
begin
i := 0;
If dataleader > 1 then
begin
InitializeField (fheader [1], '000', 'C', pred (dataleader), 0);
Inc (i);
end;
l := totalfields;
If dataleader > 1 then Inc (l);
If datatrailer > 0 then
begin
InitializeField (fheader [succ (totalfields)], 'XXX', 'C', datatrailer, 0);
Inc (l);
end;
InitializeHeader (fheader, l, recordsize, False);
FillChar (fheader [succ (l)], 1, #13);
For j := 1 to totalfields do
begin
AStr := copy (title,
screentab [j],
(screentab [succ (j)])-(screentab [j])-1);
While AStr [length (AStr)] = ' ' do Dec (AStr [0]);
While (length (AStr) > 0) and (AStr [1] = ' ') do Delete (AStr,1,1);
If AStr = '' then
Str (j:0,AStr)
else
begin
If length (AStr) > 11 then AStr [0] := #11;
For m := 1 to length (AStr) do AStr [m] := upcase (AStr [m]);
end;
If upcase (datatype [j]) = 'N' then
begin
l := 0;
k := screentab [j];
While (k < screentab [succ (j)] - 1) and (dataformat [k] <> '.') do
Inc (k);
Inc (k);
While (k < screentab [succ (j)] - 1) do
begin
If upcase (dataformat [k]) = 'N' then Inc (l);
Inc (k);
end;
InitializeField (fheader [i + j], AStr, 'N', datatab [i + j], l);
end
else
begin
InitializeField (fheader [i + j], AStr, 'C', datatab [i + j], 0);
end;
end;
end; { dBASEnew }
{ ─────────────────────────────────────────────────────────────────────── }
procedure dBMXwindow.dBASEopen (var Data; Size : longint; var F );
var i : word;
begin
If Size > 0 then FillChar (Data, Size, ' ');
If dataleader = 0 then
AdjustRecSize (1,0,0);
{ This accounts for the one byte in front of each record,
which is expected by dBASE.
The second parameter would indicate how many undisplayed bytes
there may be at the end of each record.
The third parameter would represent how many bytes to add (or
subtract, if negative) to the working record size.
This is an advanced feature called "phantom bytes".
Note that each call to AdjustRecSize is cumulative. }
If filerec (F).mode = fmClosed then
begin
Reset (dbfile (F));
DiskError := IoResult;
end
else
DiskError := 0;
If DiskError = 0 then
begin
ReadNextBlock (F, fheader, (succ (totalfields) * sizeof (headertype)) + 1);
If not IoError and (Size > 0) then
begin
recordlimit := fheader [0].numrecs;
LoadDataBlock (Data, Size, F);
end;
end
else
begin
dBASEnew;
fheader [0].numrecs := recordlimit;
ReWrite (dbfile (F));
If not IoError then
begin
Close (dbfile (F));
Reset (dbfile (F));
If not IoError then
begin
WriteNextBlock (F, fheader, fheader [0].headerlen);
DiskError := IoResult;
end;
end;
end;
end; { dBASEopen }
{ ─────────────────────────────────────────────────────────────────────── }
procedure dBMXwindow.dBASEwrite (var Data; var F );
{ use this if you are editing the whole file in memory }
var i : word;
begin
If filerec (F).mode = fmClosed then
begin
Reset (dbfile (F));
If IoError then
begin
ReWrite (dbfile (F));
DiskError := IoResult;
end;
end
else
DiskError := 0;
If DiskError = 0 then
begin
fheader [0].numrecs := recordlimit;
WriteNextBlock (F, fheader, fheader [0].headerlen);
If not IoError then SaveDataBlock (Data, F);
end;
end; { dBASEwrite }
{ ─────────────────────────────────────────────────────────────────────── }
procedure dBrowser.EvaluateRecord (RecNum : longint; Line : word);
{ this virtual method writes a record to the disk after every change }
var filler : array [0..255] of char;
begin
If changemade then
begin
If fheader [0].numrecs < RecNum + 1 then
begin
If fheader [0].numrecs < RecNum then
begin
FillChar (filler, sizeof (filler), ' ');
SeekByte (workfile,
fheader [0].headerlen + (fheader [0].numrecs * recordsize));
While (IoResult = 0) and (fheader [0].numrecs < RecNum) do
begin
WriteNextBlock (workfile, filler, recordsize);
Inc (fheader [0].numrecs);
end;
end;
fheader [0].numrecs := RecNum + 1;
end;
SeekByte (workfile, fheader [0].headerlen + (recnum * recordsize));
WriteNextBlock (workfile, dbfrecord, recordsize);
changemade := False;
end;
end; { EvaluateRecord }
function dBrowser.DataAt (recnum : longint) : pointer;
{ this virtual method retrieves the record from the file }
begin
FillChar (dbfrecord, sizeof (dbfrecord), ' ');
SeekByte (workfile, fheader [0].headerlen + (recnum * recordsize));
ReadNextBlock (workfile, dbfrecord, recordsize);
DiskError := IoResult;
DataAt := addr (dbfrecord);
end;
procedure dBrowser.ZeroizeRecord (var Data );
{ this virtual method zeroizes the record from the file after a ^Y }
begin
FillChar (dbfrecord, sizeof (dbfrecord), ' ');
DisplayRecord (Data, linenumber);
SeekByte (workfile, fheader [0].headerlen + (currentrec * recordsize));
WriteNextBlock (workfile, dbfrecord, recordsize);
fieldnum := 1;
changemade := False;
end;
{ ─────────────────────────────────────────────────────────────────────── }
procedure dBrowser.dBASEinit (Filename : pathstr);
{ use this if you are editing the file on disk }
var Data : byte;
begin
Assign (workfile,Filename);
dBASEopen (Data, 0, workfile);
end;
{ ─────────────────────────────────────────────────────────────────────── }
procedure dBrowser.dBASEclose;
{ use this if you are editing the file on disk }
begin
If filerec (workfile).mode <> fmClosed then
begin
Seek (workfile, 0);
WriteNextBlock (workfile, fheader, 32);
DiskError := IoResult;
Close (workfile);
end;
end;
{ ─────────────────────────────────────────────────────────────────────── }
End.